perm filename PT[MSS,LCS] blob sn#238781 filedate 1976-09-28 generic text, type T, neo UTF8
00100		SUBROUTINE PT2
00200		INTEGER VALID
00300		DIMENSION VALID(6),NBAR(36)
00400		DATA QLINE/140.0/,HX/2./,VALID/1,4,8,2,3,-2/,SLSP/11.0/
00500	C  QLINE=BASIC LINE LENGTH, HX=HEIGHT MULTIPLIER, ZL=LN. LNGTH FACTOR.
00600	
00700	C  ADD MORE TO VALID LATER *****
00800		COMMON /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG,JPG,BRACK,
00900		1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(-3/4)
01000		COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
01100		COMMON/STF/RSTFAC(-3/4),RSTJ2 /IVV/IV(1)
01200		COMMON /POSI/STFF(-3/4),JJ2,JPQ /LLL/L,LL,I,RXQ
01300		1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1)
01400		EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
01500		1,(R8,RQ(6)),(R9,RQ(7)),(LCNT,IV(80)),(NDPY,IV(81))
01600	C  TRNSP'S Bb, F, BBb, A, G, Eb.
01700		NAMQ='AAAAA'
01800		LL=0
01900		NBAR(1)=0
02000	5	FORMAT(F,2I)
02100		IF(RS.NE.'OLD')GO TO 2000
02200		CALL GETFIL('PARTS')
02300		CALL FASTIN(RSTFAC,128)
02400		CALL FASTIN(KPN,JJ2)
02500		CALL FASTIN(Q,JPQ)
02600	2000	TYPE 144
02700	144	FORMAT(' STAFF SIZE, TRANSP.  '$)
02800		ACCEPT 5,RSTJ2,LL
02900		IF(MOD(LL,7).EQ.0)GO TO 140
03000		DO 40 L=1,6
03100	40	IF(LL.EQ.VALID(L))GO TO 140
03200		TYPE 240
03300		GO TO 2000
03400	240	FORMAT(' THIS TRANSP NOT OFFERED')
03500	140	IF(IPG)GO TO 41
03600		IF(RSTJ2.EQ.0)GO TO 41
03700		RA=RSTJ2/RPSZ(1)
03800		DO 141 K=1,JPG
03900	141	RPSZ(K)=RPSZ(K)*RA
04000		
04100	41	IF(RSTJ2.EQ.0)RSTJ2=.9
04200		L=JJ2-2
04300		TR=LL
04400		IF(LL.NE.0)CALL TRNSP(L,TR)
04500		I=L
04600		KK=1
04700	C  FOUND A BAR LINE
04800		ENDLN=ENDL(JJ)
04900	C  FUNCTION ENDL(JJ) (IN FAIL) DOES ALL ABOVE
05000	
05100		NA=1000
05200		N=0
05300		TYPE 90,JJ
05400		RA=0
05500	90	FORMAT(' NUMBER OF BARS PER LINE: TOTAL BAR LINES='I3/)
05600		ZLINE=QLINE
05700	9	KL=0
05800		XLINE=ZLINE
05900		J=0
06000		LL=0
06100		DO 8 K=1,JJ
06200		IF(RN(K).LT.XLINE)GO TO 8
06300		KP=K-KL
06400	C  NUMBER OF BARS, THIS LINE
06500	CC	TYPE 89,KP
06600		KL=K
06700		J=J+1
06800		IF(IV(J).NE.KP)LL=-1
06900		IV(J)=KP
07000		XLINE=RN(K)+ZLINE
07100		IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
07200	8	CONTINUE
07300		IF(LL)TYPE 108,RA,(IV(K),K=1,J)
07400		IF(RT)GO TO 105
07500	108	FORMAT(F6.2,8(3I3,1X))
07600	CC	TYPE 108
07700	CC108	FORMAT(/)
07800	CC89	FORMAT('+',I3,$)
07900		IF(J.GT.NA)GO TO 107
08000		IF(N.EQ.0)GO TO 105
08100	C  SKIP IF FIRST TIME
08200		IF(N.NE.KP)GO TO 106
08300		IF(J.EQ.NA)GO TO 105
08400	106	RT=.05
08500	C SHRINK OR EXPAND?
08600		RA=RA+RT
08700		ZLINE=QLINE*RS/RA
08800		GO TO 9
08900	1107	TYPE 111,KA
09000	107	FORMAT(' CAN''T DO IT!')
09100		TYPE 107
09200	105	TYPE 104,J
09300	104	FORMAT(I4,' LINES - OR TYPE N1, N2 --'$)
09400		KA=0
09500		ACCEPT 5,RA,N,KL
09600	C  TYPE 0,n  TO EXIT WITH n SPACING BETWEEN STAVES (2 IS DEFAULT)
09700		IF(KL.NE.0)GO TO 110
09800	C  FOR SPECIFICATION OF HOW MANY BARS ON EACH LINE
09900	C NO MORE THAN 36 NUMS, INCLUDING 0S (FOR PAGE MARKS)
10000		IF(RA.EQ.0)GO TO 11
10100		IF(ZLINE.EQ.QLINE)RS=J
10200		NA=RA
10300		RT=NA-RA
10400		IF(RT)GO TO 109
10500		RA=RA-.6
10600	C  CHECK THIS ↑↑↑ NUMBER!
10700		IF(N.EQ.0)GO TO 90
10800	109	ZLINE=QLINE*RS/RA
10900		GO TO 9
11000	
11100	111	FORMAT(36I)
11200	110	REREAD 111,NBAR
11300	911	DO 112 K=36,1,-1
11400		KP=NBAR(K)
11500		KA=KA+KP
11600	112	IF(KP.EQ.0.AND.KA.EQ.0)KL=K
11700		IF(KA.NE.JJ)GO TO 1107
11800	C  MISMATCH!
11900		N=26-2*MOD(KL-1,12)
12000		IF(N.EQ.26)N=0
12100	C  TO SPACE OUT STAVES VERTICALLY
12200	
12300	11	RA=0
12400		IF(IPG)GO TO 811
12500		IF(NBAR(1).NE.0)GO TO 811
12600		DO 711 K=1,36
12700		IF(K.GT.J)IV(K)=0
12800	711	NBAR(K)=IV(K)
12900		GO TO 911
13000	811	JEND=-1
13100		XLINE=ZLINE
13200		CLEF=-99
13300		JSLUR=0
13400		LC=1
13500		SIG=CLEF
13600		HX=2
13700		SP=2.45
13800	C  DEFAULT VERT. SPACE UNITS
13900		IF(N.EQ.0)GO TO 100
14000	C  SPACED OUT DEPENDING ON NUM OF LINES
14100		HX=N
14200		SP=SP+(HX-2.)*.11
14300	100	KL=1
14400		IF(JEND.EQ.0)GO TO 1000
14500	103	FORMAT(' TYPE OUTPUT FILE NAME  ',$)
14600	102	FORMAT(A5)
14700		TYPE 103
14800		ACCEPT 102,NAMX
14900		IF(NAMX.EQ.' ')NAMX=NAMQ
15000		NAMZ=NAMX
15100		NPG=1
15200		RA=JPG*RSTJ2
15300		MPG=10./RA
15400	C  MPG=NUM OF BRACES PER PAGE.
15500		SPG=12./MPG
15600	C  SPG IS SPACE TO BE SET ABOVE STAFF 0
15700		IF(LOOKF(NAMX).GE.0)GO TO 88
15800		TYPE 88,NAMX
15900		ACCEPT 102,L
16000		IF(L.EQ.'N')GO TO 103
16100	88	FORMAT(' WRITE OVER FILE ',A5,'????  '$)
16200	1000	KP=1
16300		JEND=0
16400	C  FLAG FOR PAGE END - WHEN -1
16500		RT=2
16600		J=KK
16700		HGT=HX*2.
16800		LB=0
16900		MTR1=-1
17000	
17100		DO 1 K=KK,I
17200		N=KPN(K)
17300		IF(Q(N+1).NE.4)GO TO 1
17400		IF(KA.EQ.0)GO TO 334
17500		LB=LB+1
17600	C  BAR COUNTER
17700		IF(NBAR(LC).GT.LB)GO TO 1
17800	C FOR SPECIFIED BARS
17900		LC=LC+1
18000		LB=0
18100		IF(NBAR(LC).NE.0)GO TO 335
18200		JEND=-1
18300		LC=LC+1
18400		GO TO 335
18500	334	IF(Q(N+3).LT.XLINE)GO TO 1
18600	C  FOUND LAST BAR LINE.
18700	335	RX=0
18800		MTR1=-1
18900		MTR2=-1
19000		LL=KPN(K+1)
19100	C TO ADD METER AT END OF BAR
19200		RS=Q(LL+1)
19300		IF(RS.LE.4)GO TO 3
19400		IF(RS.EQ.18)MTR1=LL
19500	C WHAT ABOUT REHRSL NUMS, ETC??
19600		LL=KPN(K+2)
19700		RS=Q(LL+1)
19800		IF(RS.LE.4)GO TO 3
19900		IF(IPG)GO TO 4011
20000		IF(Q(LL+2).NE.Q(N+2))GO TO 4111
20100	4011	IF(RS.EQ.18)MTR2=LL
20200		LL=KPN(K+3)
20300		IF(IPG)GO TO 4211
20400		IF(Q(LL+2).NE.Q(N+2))GO TO 4111
20500	4211	IF(Q(LL+1).EQ.18)MTR2=LL
20600	4111	IF(MTR1.GT.0)GO TO 3
20700		MTR1=MTR2
20800		MTR2=-1
20900	C IN CASE IT SAW SOMETHING AHEAD OF NEW METER
21000	3	JJ=KP
21100	C PUTS IN STAFF
21200		RS=3.
21300		IF(RT.NE.0)GO TO 331
21400	C NEXT FOR BOTTOM STAFF.  PUTS IN SPACER.
21500		RS=6.
21600	331	IF(IPG)GO TO 411
21700		HX=8
21800		RZ=0
21900		RX=RT
22000		DO 611 JP=1,JPG
22100		RT=RSTNUM(JP)
22200		RS=3
22300	C WD CNT IS RS, HX IS CODE(8), ARRAYS AND JPG WERE SET UP IN MAIN.
22400		RR=0
22500		IF(JP.GT.1)GO TO 611
22550		IF(NAMX.EQ.NAMZ)GO TO 611
22600		RS=6
22700		RR=SPG
22800	C  FOR SPACER ON STAFF 0
22900	611	CALL STAFF(RS,HX,RZ,RHGT(JP),RPSZ(JP),RZ,RZ,RR)
23000		HX=JPG
23100		RS=4.
23200		RT=0
23300		CALL STAFF(2.,RS,RZ,HX,RZ,RZ,RZ,RZ)
23400		IF(BRACK.NE.0)CALL STAFF(5.,RS,RZ,HX,RZ,RZ,BRACK,RZ)
23500		RT=RX
23600		GO TO 511
23700	411	CALL STAFF(RS,8.,0,HGT,RSTJ2,0,0,SP)
23800		HGT=HGT-HX
23900	511	IF(XLINE.EQ.ZLINE)GO TO 33
24000		IF(JEND)GO TO 60
24100	C FOR PREMATURE PAGE END
24200		IF(K.NE.I)GO TO 6
24300		IF(RT.EQ.0)GO TO 6
24400	60	IF(IPG.EQ.0)GO TO 6
24500		RX=RT
24600		RT=0
24700		CALL STAFF(6.,8.,0,0,0,0,1.,SP)
24800	C  PUTS IN SPACER
24900		RT=RX
25000	6	IF(JSLUR.EQ.0)GO TO 2333
25100	CC	LL=JSLUR
25200	CC	JSLUR=0
25300		CALL JSL(JSLUR)
25400	1333	CALL STAFF(5.,5.,0,Q(LL),Q(LL+1),SLSP,Q(LL+3),0)
25500	2333	IF(JSL2.EQ.0)GO TO 333
25600	CC	LL=JSL2
25700	C FOR 2ND SLUR AT END OF LINE.
25800	CC	JSL2=0
25900		CALL JSL(JSL2)
26000		GO TO 1333
26100	333	IF(CLEF.EQ.-99)GO TO 33
26200	C  ONLY STAFF FOR FIRST LINE AT TOP.
26300		RX=10.*RSTJ2
26400	C  THE SPACER
26500		LA=0
26600		IF(IPG)GO TO 3011
26700		LA=JPG
26800	3111	RT=RSTNUM(LA)
26900		LL=RT
27000		CLEF=RCLEF(LL)
27100	C GETS CLEF FOR PAGE LAYOUT, RT IS STAFF# IN CALL
27200		LA=LA-1
27300	3011	CALL STAFF(3.,3.,1.5,0,CLEF,0,0,0)
27400		IF(SIG.EQ.-99)GO TO 3211
27500		RS=4.
27600		R5=SIG
27700	CC	RX=CLEF
27800	CC	IF(R5.LT.50)GO TO 332
27900	CC	RX=IFIX((R5+50.)/100.)
28000	CC	R5=R5-RX*100.
28100	C  CLEF+SIG
28200	332	CALL STAFF(RS,17.,11.0*RSTJ2,0,R5,CLEF,0,0)
28300		RX=12.*RSTJ2
28400	3211	IF(LA.GT.0)GO TO 3111
28500	
28600	33	R4=RA
28700		R5=Q(N+3)
28800		RS=0
28900		R7=RT
29000		R8=RX
29100		R9=200.
29200		LL=0
29300		L=K-J+1
29400		CALL PTMOVE(Q,KPN(J))
29500		RA=R5
29600	31	IF(MTR1)GO TO 231
29700		LA=0
29800		IF(IPG)GO TO 5011
29900		LA=JPG
30000	5111	RT=RSTNUM(LA)
30100	C  PUT METER ON ALL STAVES FOR PAGE LAYOUT
30200		LA=LA-1
30300	5011	R=200.0+2.23*RSTJ2
30400		CALL STAFF(Q(MTR1),Q(MTR1+1),R,0,Q(MTR1+5),Q(MTR1+6),0,0)
30500	C  PUTS METER AFTER END OF STAFF
30600		IF(MTR2)GO TO 5211
30700		R=200.0+6.7*RSTJ2
30800		CALL STAFF(Q(MTR2),Q(MTR2+1),R,0,Q(MTR2+5),Q(MTR2+6),0,0)
30900	C  PUTS COMPOSITE METER AFTER END OF STAFF
31000	5211	IF(LA.GT.0)GO TO 5111
31100	231	KB=KL
31200	131	DO 30 NA=KK,K
31300		KWDS(KP)=KB
31400		KP=KP+1
31500		JK=KPN(NA)
31600		R=Q(JK+1)
31700		IF(R.EQ.5)GO TO 135
31800		IF(R.NE.44)GO TO 35
31900	135	RR=Q(JK+6)
32000		IF(RR.LT.Q(JK+3))GO TO 635
32100	C  NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
32200		IF(RR.LT.199.)GO TO 37
32300	C CATCHES END OF SLUR AND VARIOUS LINES
32400	635	IF(R.NE.5)GO TO 37
32500	C  TO PUT SLUR ON NEXT LINE.
32600	C*********** IS SOMETHING MISSING HERE????????  4/76
32700	235	IF(JSLUR.NE.0)GO TO 435
32800	CC	JSLUR=JK+4
32900		JSLUR=JSLX(JK)
33000		GO TO 535
33100	CC435	JSL2=JK+4
33200	435	JSL2=JSLX(JK)
33300	C FOR 2ND SLUR
33400	535	RR=201
33500		IF(Q(JK+8).LT.-1)RR=202
33600		Q(JK+6)=RR
33700		IF(R.EQ.5)GO TO 30
33800		GO TO 38
33900	
34000	35	IF(R.NE.2)GO TO 36
34100		IF(Q(JK).LT.6.)GO TO 30
34200		RR=RIGHT(NA,-1)
34300		IF(RR.GE.199.)RR=RX
34400		Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1)-RR)/2.
34500	C  FUNCTION 'RIGHT' FINDS RIGHT ITEMS FOR CENTERING.
34600	C CENTERS WHOLE REST
34700		GO TO 30
34800	36	IF(R.NE.3)GO TO 34
34900	CC	RR=Q(JK+5)
35000	CC	IF(Q(JK).LT.3)RR=0
35100	CC	CLEF=AMOD(RR,100.0)
35200		CLEF=CLEFN(Q,JK)
35300		IF(IPG)GO TO 30  
35400		LL=Q(JK+2)
35500	C GETS CLEF FOR PAGE LAYOUT
35600		RCLEF(LL)=CLEF
35700		GO TO 30
35800	34	IF(R.NE.17)GO TO 37
35900		SIG=Q(JK+5)
36000		IF(ABS(SIG).GT.100.)SIG=-99
36100	C  DO NOT REPEAT KSIG MADE UP OF NATURALS.
36200	CXX	IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
36300	CXX  CLEF # IN P6 WITH KEY SIGS.
36400	C  NEXT CHANGES CODE NUM BACK TO ORIGINAL
36500	37	IF(R.LT.33)GO TO 30
36600	38	Q(JK+1)=R/11.
36700	30	KB=KPN(NA+1)-KPN(NA)+KB
36800	
36900		CALL PSHFT(KK,K)
37000		RS=RT
37100		LL='J'
37200		R4=0
37300		R5=200
37400		NA=L
37500		L=KP-JJ
37600		CALL PTMOVE(RN,KWDS(JJ))
37700		DO 47 JJ2=JJ,KP
37800		LL=KWDS(JJ2)
37900		AA=RN(LL+1)
38000		IF(AA.NE.10.AND.AA.NE.16)GO TO 347
38100		DO 147 NN=JJ2+1,KP
38200		MM=KWDS(NN)
38300		IF(RN(MM+1).NE.16)GO TO 147
38400	C  FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
38500		IF(RN(MM).EQ.8)GO TO 47
38600	C  JUMP IF POS. IS ALREADY TAKEN CARE OF.
38700		IF(AA.EQ.10)GO TO 247
38800	C NEXT FOR TEXT FOLLOWING TEXT
38900		IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
39000	C JUMP IF ON DIFF. VERT. PLANE.
39100		AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
39200	C  SETS MINIMUM SPACE.
39300		IF(RN(MM+3).LT.AA)RN(MM+3)=AA
39400		GO TO 47
39500	247	IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
39600	C  CHECKS VERT. POS.
39700		AA=RN(LL+4)+7
39800		IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
39900	C  MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
40000		GO TO 47
40100	147	CONTINUE
40200		GO TO 47
40300	347	IF(AA.NE.5)GO TO 1047
40400	C TO IMPROVE SLUR PARAMETERS
40500		R8=RN(LL+8)
40600		IF(RN(LL).LT.6)R8=0
40700		IF(R8.GT.0)GO TO 47
40800	C  JUMP IF A BRACKET
40900		R=RN(LL+6)
41000	
41100		DO 647 NN=JJ2+1,KP
41200		MM=KWDS(NN)
41300	C  THIS IS TO FIND SLURS AT END OF OLD LINES AND EXTEND THEM
41400		IF(RN(MM+1).NE.4)GO TO 647
41500	C FIND A BAR LINE
41600		IF(RN(MM+3).GT.199.)GO TO 647
41700	C  IGNORE LAST BAR OR LINE.
41800		IF(RN(MM).GT.2)GO TO 647
41900		AA=ABS(RN(MM+3)-R)
42000		IF(AA.GT.1.)GO TO 647
42100		RN(LL+6)=R+4
42200		GO TO 47
42300	647	CONTINUE
42400	
42500		R7=RN(LL+7)
42600		R9=R-RN(LL+3)+(R8+1.)*2.
42700		IF(R9.GT.7)GO TO 47
42800	C  NO WORK NEEDED.  IT'S LONG ENOUGH
42900		IF(RN(LL).GT.5)RN(LL+8)=-1
43000		R=1.
43100		IF(R7.LT.0)R=-R
43200	547	RN(LL+4)=RN(LL+4)+R
43300		RN(LL+5)=RN(LL+5)+R
43400	C  WERE +AA ↑↑↑↑↑
43500		RN(LL+7)=R
43600		GO TO 47
43700	1047	IF(AA.NE.6)GO TO 47
43800		IF(RN(LL).LT.7)GO TO 47
43900		IF(RN(LL+9).GT.200.)RN(LL+9)=0
44000	C ********** FIX THIS IN GETPTS, MOVER.  IT SHOULDN'T MOVE P9 ALWAYS.
44100	47	CONTINUE
44200	
44300		IF(K.EQ.I)GO TO 2
44400		L=NA
44500		J=K+1
44600	C  SO IT DOESN'T GO THRU ALL DATA
44700		RT=RT-1
44800		XLINE=RA+ZLINE
44900		IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
45000		IF(IPG.EQ.0)GO TO 2  
45100	C  OMIT NEXT FOR PAGE LAYOUT ONLY
45200	10	IF(KL.GT.1700.OR.KP.GT.190.OR.RT.OR.JEND)GO TO 2
45300	1	IF(K.EQ.I)GO TO 3
45400	2	KWDS(KP)=KB
45500		J=1
45600		JJ2=KP+1
45700		JPQ=KB
45800	C  WRITES 1 EXTRA WORD
45900		CALL PUTFIL(NAMX)
46000		LCNT=0
46100		NDPY=0
46200		CALL FASTOU(RSTFAC,128)
46300		CALL FASTOU(KWDS,JJ2)
46400		CALL FASTOU(RN,JPQ)
46500		TYPE 101,NAMX
46600		IF(KK.GE.I)CALL EXIT
46700		NAMX=NAMX+2
46800		IF(IPG)GO TO 6011
46900		NPG=NPG+1
47000		IF(NPG.LE.MPG)GO TO 6011
47100		NPG=1
47200	C RESET, UPDATE FILENAMES
47300		NAMX=NAMZ+256
47400		NAMZ=NAMX
47500	6011	NAMQ=NAMX
47600		CALL FINFIL
47700		GO TO 100
47800	101	FORMAT(1XA5)
47900		END
48000